home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / fortran / f2c_src.zip / F2C / IO.C < prev    next >
C/C++ Source or Header  |  1991-06-10  |  30KB  |  1,417 lines
  1. /****************************************************************
  2. Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. /* Routines to generate code for I/O statements.
  25.    Some corrections and improvements due to David Wasley, U. C. Berkeley
  26. */
  27.  
  28. /* TEMPORARY */
  29. #define TYIOINT TYLONG
  30. #define SZIOINT SZLONG
  31.  
  32. #include "defs.h"
  33. #include "names.h"
  34. #include "iob.h"
  35.  
  36. extern int inqmask;
  37.  
  38. LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(),
  39.     doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(),
  40.     putio(), putiocall();
  41.  
  42. iob_data *iob_list;
  43. Addrp io_structs[9];
  44.  
  45. LOCAL char ioroutine[12];
  46.  
  47. LOCAL long ioendlab;
  48. LOCAL long ioerrlab;
  49. LOCAL int endbit;
  50. LOCAL int errbit;
  51. LOCAL long jumplab;
  52. LOCAL long skiplab;
  53. LOCAL int ioformatted;
  54. LOCAL int statstruct = NO;
  55. LOCAL struct Labelblock *skiplabel;
  56. Addrp ioblkp;
  57.  
  58. #define UNFORMATTED 0
  59. #define FORMATTED 1
  60. #define LISTDIRECTED 2
  61. #define NAMEDIRECTED 3
  62.  
  63. #define V(z)    ioc[z].iocval
  64.  
  65. #define IOALL 07777
  66.  
  67. LOCAL struct Ioclist
  68. {
  69.     char *iocname;
  70.     int iotype;
  71.     expptr iocval;
  72. }
  73. ioc[ ] =
  74. {
  75.     { "", 0 },
  76.     { "unit", IOALL },
  77.     { "fmt", M(IOREAD) | M(IOWRITE) },
  78.     { "err", IOALL },
  79.     { "end", M(IOREAD) },
  80.     { "iostat", IOALL },
  81.     { "rec", M(IOREAD) | M(IOWRITE) },
  82.     { "recl", M(IOOPEN) | M(IOINQUIRE) },
  83.     { "file", M(IOOPEN) | M(IOINQUIRE) },
  84.     { "status", M(IOOPEN) | M(IOCLOSE) },
  85.     { "access", M(IOOPEN) | M(IOINQUIRE) },
  86.     { "form", M(IOOPEN) | M(IOINQUIRE) },
  87.     { "blank", M(IOOPEN) | M(IOINQUIRE) },
  88.     { "exist", M(IOINQUIRE) },
  89.     { "opened", M(IOINQUIRE) },
  90.     { "number", M(IOINQUIRE) },
  91.     { "named", M(IOINQUIRE) },
  92.     { "name", M(IOINQUIRE) },
  93.     { "sequential", M(IOINQUIRE) },
  94.     { "direct", M(IOINQUIRE) },
  95.     { "formatted", M(IOINQUIRE) },
  96.     { "unformatted", M(IOINQUIRE) },
  97.     { "nextrec", M(IOINQUIRE) },
  98.     { "nml", M(IOREAD) | M(IOWRITE) }
  99. };
  100.  
  101. #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
  102. #define MAXIO    SZFLAG + 10*SZIOINT + 15*SZADDR
  103.  
  104. /* #define IOSUNIT 1 */
  105. /* #define IOSFMT 2 */
  106. #define IOSERR 3
  107. #define IOSEND 4
  108. #define IOSIOSTAT 5
  109. #define IOSREC 6
  110. #define IOSRECL 7
  111. #define IOSFILE 8
  112. #define IOSSTATUS 9
  113. #define IOSACCESS 10
  114. #define IOSFORM 11
  115. #define IOSBLANK 12
  116. #define IOSEXISTS 13
  117. #define IOSOPENED 14
  118. #define IOSNUMBER 15
  119. #define IOSNAMED 16
  120. #define IOSNAME 17
  121. #define IOSSEQUENTIAL 18
  122. #define IOSDIRECT 19
  123. #define IOSFORMATTED 20
  124. #define IOSUNFORMATTED 21
  125. #define IOSNEXTREC 22
  126. #define IOSNML 23
  127.  
  128. #define IOSTP V(IOSIOSTAT)
  129.  
  130.  
  131. /* offsets in generated structures */
  132.  
  133. #define SZFLAG SZIOINT
  134.  
  135. /* offsets for external READ and WRITE statements */
  136.  
  137. #define XERR 0
  138. #define XUNIT    SZFLAG
  139. #define XEND    SZFLAG + SZIOINT
  140. #define XFMT    2*SZFLAG + SZIOINT
  141. #define XREC    2*SZFLAG + SZIOINT + SZADDR
  142. #define XRLEN    2*SZFLAG + 2*SZADDR
  143. #define XRNUM    2*SZFLAG + 2*SZADDR + SZIOINT
  144.  
  145. /* offsets for internal READ and WRITE statements */
  146.  
  147. #define XIERR    0
  148. #define XIUNIT    SZFLAG
  149. #define XIEND    SZFLAG + SZADDR
  150. #define XIFMT    2*SZFLAG + SZADDR
  151. #define XIRLEN    2*SZFLAG + 2*SZADDR
  152. #define XIRNUM    2*SZFLAG + 2*SZADDR + SZIOINT
  153. #define XIREC    2*SZFLAG + 2*SZADDR + 2*SZIOINT
  154.  
  155. /* offsets for OPEN statements */
  156.  
  157. #define XFNAME    SZFLAG + SZIOINT
  158. #define XFNAMELEN    SZFLAG + SZIOINT + SZADDR
  159. #define XSTATUS    SZFLAG + 2*SZIOINT + SZADDR
  160. #define XACCESS    SZFLAG + 2*SZIOINT + 2*SZADDR
  161. #define XFORMATTED    SZFLAG + 2*SZIOINT + 3*SZADDR
  162. #define XRECLEN    SZFLAG + 2*SZIOINT + 4*SZADDR
  163. #define XBLANK    SZFLAG + 3*SZIOINT + 4*SZADDR
  164.  
  165. /* offset for CLOSE statement */
  166.  
  167. #define XCLSTATUS    SZFLAG + SZIOINT
  168.  
  169. /* offsets for INQUIRE statement */
  170.  
  171. #define XFILE    SZFLAG + SZIOINT
  172. #define XFILELEN    SZFLAG + SZIOINT + SZADDR
  173. #define XEXISTS    SZFLAG + 2*SZIOINT + SZADDR
  174. #define XOPEN    SZFLAG + 2*SZIOINT + 2*SZADDR
  175. #define XNUMBER    SZFLAG + 2*SZIOINT + 3*SZADDR
  176. #define XNAMED    SZFLAG + 2*SZIOINT + 4*SZADDR
  177. #define XNAME    SZFLAG + 2*SZIOINT + 5*SZADDR
  178. #define XNAMELEN    SZFLAG + 2*SZIOINT + 6*SZADDR
  179. #define XQACCESS    SZFLAG + 3*SZIOINT + 6*SZADDR
  180. #define XQACCLEN    SZFLAG + 3*SZIOINT + 7*SZADDR
  181. #define XSEQ    SZFLAG + 4*SZIOINT + 7*SZADDR
  182. #define XSEQLEN    SZFLAG + 4*SZIOINT + 8*SZADDR
  183. #define XDIRECT    SZFLAG + 5*SZIOINT + 8*SZADDR
  184. #define XDIRLEN    SZFLAG + 5*SZIOINT + 9*SZADDR
  185. #define XFORM    SZFLAG + 6*SZIOINT + 9*SZADDR
  186. #define XFORMLEN    SZFLAG + 6*SZIOINT + 10*SZADDR
  187. #define XFMTED    SZFLAG + 7*SZIOINT + 10*SZADDR
  188. #define XFMTEDLEN    SZFLAG + 7*SZIOINT + 11*SZADDR
  189. #define XUNFMT    SZFLAG + 8*SZIOINT + 11*SZADDR
  190. #define XUNFMTLEN    SZFLAG + 8*SZIOINT + 12*SZADDR
  191. #define XQRECL    SZFLAG + 9*SZIOINT + 12*SZADDR
  192. #define XNEXTREC    SZFLAG + 9*SZIOINT + 13*SZADDR
  193. #define XQBLANK    SZFLAG + 9*SZIOINT + 14*SZADDR
  194. #define XQBLANKLEN    SZFLAG + 9*SZIOINT + 15*SZADDR
  195.  
  196. LOCAL char *cilist_names[] = {
  197.     "cilist",
  198.     "cierr",
  199.     "ciunit",
  200.     "ciend",
  201.     "cifmt",
  202.     "cirec"
  203.     };
  204. LOCAL char *icilist_names[] = {
  205.     "icilist",
  206.     "icierr",
  207.     "iciunit",
  208.     "iciend",
  209.     "icifmt",
  210.     "icirlen",
  211.     "icirnum"
  212.     };
  213. LOCAL char *olist_names[] = {
  214.     "olist",
  215.     "oerr",
  216.     "ounit",
  217.     "ofnm",
  218.     "ofnmlen",
  219.     "osta",
  220.     "oacc",
  221.     "ofm",
  222.     "orl",
  223.     "oblnk"
  224.     };
  225. LOCAL char *cllist_names[] = {
  226.     "cllist",
  227.     "cerr",
  228.     "cunit",
  229.     "csta"
  230.     };
  231. LOCAL char *alist_names[] = {
  232.     "alist",
  233.     "aerr",
  234.     "aunit"
  235.     };
  236. LOCAL char *inlist_names[] = {
  237.     "inlist",
  238.     "inerr",
  239.     "inunit",
  240.     "infile",
  241.     "infilen",
  242.     "inex",
  243.     "inopen",
  244.     "innum",
  245.     "innamed",
  246.     "inname",
  247.     "innamlen",
  248.     "inacc",
  249.     "inacclen",
  250.     "inseq",
  251.     "inseqlen",
  252.     "indir",
  253.     "indirlen",
  254.     "infmt",
  255.     "infmtlen",
  256.     "inform",
  257.     "informlen",
  258.     "inunf",
  259.     "inunflen",
  260.     "inrecl",
  261.     "innrec",
  262.     "inblank",
  263.     "inblanklen"
  264.     };
  265.  
  266. LOCAL char **io_fields;
  267.  
  268. #define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
  269.  
  270. LOCAL io_setup io_stuff[] = {
  271.     zork(cilist_names, TYCILIST),    /* external read/write */
  272.     zork(inlist_names, TYINLIST),    /* inquire */
  273.     zork(olist_names,  TYOLIST),    /* open */
  274.     zork(cllist_names, TYCLLIST),    /* close */
  275.     zork(alist_names,  TYALIST),    /* rewind */
  276.     zork(alist_names,  TYALIST),    /* backspace */
  277.     zork(alist_names,  TYALIST),    /* endfile */
  278.     zork(icilist_names,TYICILIST),    /* internal read */
  279.     zork(icilist_names,TYICILIST)    /* internal write */
  280.     };
  281.  
  282. #undef zork
  283.  
  284.  
  285. fmtstmt(lp)
  286. register struct Labelblock *lp;
  287. {
  288.     if(lp == NULL)
  289.     {
  290.         execerr("unlabeled format statement" , CNULL);
  291.         return(-1);
  292.     }
  293.     if(lp->labtype == LABUNKNOWN)
  294.     {
  295.         lp->labtype = LABFORMAT;
  296.         lp->labelno = newlabel();
  297.     }
  298.     else if(lp->labtype != LABFORMAT)
  299.     {
  300.         execerr("bad format number", CNULL);
  301.         return(-1);
  302.     }
  303.     return(lp->labelno);
  304. }
  305.  
  306.  
  307. setfmt(lp)
  308. struct Labelblock *lp;
  309. {
  310.     int n;
  311.     char *s0, *lexline();
  312.     register char *s, *se, *t;
  313.     register k;
  314.  
  315.     s0 = s = lexline(&n);
  316.     se = t = s + n;
  317.  
  318.     /* warn of trivial errors, e.g. "  11 CONTINUE" (one too few spaces) */
  319.     /* following FORMAT... */
  320.  
  321.     if (n <= 0)
  322.         warn("No (...) after FORMAT");
  323.     else if (*s != '(')
  324.         warni("%c rather than ( after FORMAT", *s);
  325.     else if (se[-1] != ')') {
  326.         *se = 0;
  327.         while(--t > s && *t != ')') ;
  328.         if (t <= s)
  329.             warn("No ) at end of FORMAT statement");
  330.         else if (se - t > 30)
  331.             warn1("Ext